2-2

Random Walks on the Plane

Nicholas Wheeler
30 August 2011

Introduction

The following material is quoted from "Simulated Random Walks" (Notebook dated 4 April 2008)

Steps of unit length, random turn angles uniformly distributed

The following commands generate the steps that contribute to a population  of four such 1000-step walks:

Steps1=Table[{Cos[α], Sin[α]}/.{α->2π RandomReal[]},{n,1,1000}];
Steps2=Table[{Cos[α], Sin[α]}/.{α->2π RandomReal[]},{n,1,1000}];
Steps3=Table[{Cos[α], Sin[α]}/.{α->2π RandomReal[]},{n,1,1000}];
Steps4=Table[{Cos[α], Sin[α]}/.{α->2π RandomReal[]},{n,1,1000}];

Here is a typical step

Part[Steps1, 137]

and here is a demonstration that (like all others) it has unit length:

Norm[%]

The following commands list the successive positions achieved by the (k^th) walker:

SuccessivePositions1=Table[(∑_(k=1)^m)Steps1[[k]], {m,1,1000}];
SuccessivePositions2=Table[(∑_(k=1)^m)Steps2[[k]], {m,1,1000}];
SuccessivePositions3=Table[(∑_(k=1)^m)Steps3[[k]], {m,1,1000}];
SuccessivePositions4=Table[(∑_(k=1)^m)Steps4[[k]], {m,1,1000}];

Here are I construct and draw graphic displays of the paths traced by the respective walkers:

RandomWalk1=Graphics[{Black,Line[SuccessivePositions1]}];
RandomWalk2=Graphics[{Red,Line[SuccessivePositions2]}];
RandomWalk3=Graphics[{Blue,Line[SuccessivePositions3]}];
RandomWalk4=Graphics[{Green,Line[SuccessivePositions4]}];

Show[RandomWalk1,RandomWalk2,RandomWalk3,RandomWalk4, Axes->True, Ticks->False]

Theoretically, we expect the average displacement achieved after N steps to grow as (Sqrt[N]). That expectation informs the design of the following figure

CircularGrid=Graphics[{Circle[{0,0},(Sqrt[100])],Circle[{0,0},(Sqrt[200])],Circle[{0,0},(Sqrt[300])],Circle[{0,0},(Sqrt[400])],Circle[{0,0},(Sqrt[500])],Circle[{0,0},(Sqrt[600])],Circle[{0,0},(Sqrt[700])],Circle[{0,0},(Sqrt[800])],Circle[{0,0},(Sqrt[900])],Circle[{0,0},(Sqrt[1000])]}];

Show[CircularGrid, RandomWalk1, RandomWalk2, RandomWalk3, RandomWalk4]

We  compute and display the evolving net displacement from the origin achieved by the respective walkers, and compare it to the theoretical expectation:

NetDisplacement1[n_]:=Norm[Part[SuccessivePositions1,n]]
NetDisplacement2[n_]:=Norm[Part[SuccessivePositions2,n]]
NetDisplacement3[n_]:=Norm[Part[SuccessivePositions3,n]]
NetDisplacement4[n_]:=Norm[Part[SuccessivePositions4,n]]

PlotNetDisplacement1=ListPlot[Table[NetDisplacement1[n],{n,1,1000}], Joined->True, PlotStyle->Black, PlotRange->{0,80}];
PlotNetDisplacement2=ListPlot[Table[NetDisplacement2[n],{n,1,1000}], Joined->True, PlotStyle->Red, PlotRange->{0,80}];
PlotNetDisplacement3=ListPlot[Table[NetDisplacement3[n],{n,1,1000}], Joined->True, PlotStyle->Blue, PlotRange->{0,80}];
PlotNetDisplacement4=ListPlot[Table[NetDisplacement4[n],{n,1,1000}], Joined->True, PlotStyle->Green, PlotRange->{0,80}];

ExpectedNetDisplacement=ListPlot[Table[(Sqrt[n]),{n,1,1000}], PlotRange->{0,80}];

Show[ExpectedNetDisplacement,PlotNetDisplacement1 ,PlotNetDisplacement2,PlotNetDisplacement3,PlotNetDisplacement4]

Normal diffusion

Let

ρ[x, y, N]dx dy=

describe the fraction of a very large population  of walkers who, after N steps, find themselves in the neighborhood [dx, dy] of the point [x, y]. Random walk theory leads to the conclusion that ρ[x, y, N] has the form of a simple bivariate normal distribution function

ρ[x_, y_, N_]:=((E^(-(((x^2)+(y^2))/(2N))))/(N (Sqrt[2 π])))

and satisfies the diffusion equation

(1/2)((∂_(x,x))+(∂_(y,y)))ρ=(∂_N)ρ

which I verify:

(1/2)(D[ρ[x,y,N],{x,2}]+D[ρ[x,y,N],{y,2}])==D[ρ[x,y,N],{N,1}]//Simplify

Here is a 3D display of the  evolving density function

Manipulate[Plot3D[ρ[x,y,N],{x,-(Sqrt[3000]),(Sqrt[3000])},{y,-(Sqrt[3000]),(Sqrt[3000])}, PlotRange->{0,0.004}],{N,100,1000,100}]

REMARK: It would take the data derived from VERY MANY WALKS (Avogadro's ((Number )^(2/3))?) to establish this result numerically, though in one dimension one needs far fewer than  Avogadro's (Number^( 1/3)) ~ (10^8) to obtain convincing results.

Superdiffusion: Levy Flights

Let step length be statistically determined. Let it, in particular, be determined by a distribution with a very "long tail," so that occasional steps are exceptionally long. Such random walks (or "flights") are used to gain insight into the mechanism that underlies the departures from the "law of diffusion" that are encountered in a wide assortment of physical (+ biological, financial) applications.

To illustrate the point, I adopt the distribution law

Levy[x_]:=PDF[FRatioDistribution[3,3.9999],x]

Plot[Levy[x],{x,0,5}]

The long tail—evident in the figure—is so long that the variance is indeterminate:

Mean[FRatioDistribution[3,3.9999]]
Variance[FRatioDistribution[3,3.9999]]

I remark in passing that the similar-looking long-tail distribution

Plot[PDF[FRatioDistribution[3,4.0001],x],{x,0,5}]

possesses a large but finite variance:

Mean[FRatioDistribution[3,4.0001]]
Variance[FRatioDistribution[3,4.0001]]

Proceeding now very much as before, we construct

LevySteps1=Table[r{Cos[α], Sin[α]}/.{r->RandomReal[FRatioDistribution[3,3.9999]],α->2π RandomReal[]},{n,1,1000}];
LevySteps2=Table[r{Cos[α], Sin[α]}/.{r->RandomReal[FRatioDistribution[3,3.9999]],α->2π RandomReal[]},{n,1,1000}];
LevySteps3=Table[r{Cos[α], Sin[α]}/.{r->RandomReal[FRatioDistribution[3,3.9999]],α->2π RandomReal[]},{n,1,1000}];
LevySteps4=Table[r{Cos[α], Sin[α]}/.{r->RandomReal[FRatioDistribution[3,3.9999]],α->2π RandomReal[]},{n,1,1000}];

SuccessiveLevyPositions1=Table[(∑_(k=1)^m)LevySteps1[[k]], {m,1,1000}];
SuccessiveLevyPositions2=Table[(∑_(k=1)^m)LevySteps2[[k]], {m,1,1000}];
SuccessiveLevyPositions3=Table[(∑_(k=1)^m)LevySteps3[[k]], {m,1,1000}];
SuccessiveLevyPositions4=Table[(∑_(k=1)^m)LevySteps4[[k]], {m,1,1000}];

LevyFlight1=Graphics[{Black,Line[SuccessiveLevyPositions1]}];
LevyFlight2=Graphics[{Red,Line[SuccessiveLevyPositions2]}];
LevyFlight3=Graphics[{Blue,Line[SuccessiveLevyPositions3]}];
LevyFlight4=Graphics[{Green,Line[SuccessiveLevyPositions4]}];

Show[LevyFlight1,LevyFlight2,LevyFlight3,LevyFlight4, Axes->True, Ticks->False]

NetLevyDisplacement1[n_]:=Norm[Part[SuccessiveLevyPositions1,n]]
NetLevyDisplacement2[n_]:=Norm[Part[SuccessiveLevyPositions2,n]]
NetLevyDisplacement3[n_]:=Norm[Part[SuccessiveLevyPositions3,n]]
NetLevyDisplacement4[n_]:=Norm[Part[SuccessiveLevyPositions4,n]]

PlotNetLevyDisplacement1=ListPlot[Table[NetLevyDisplacement1[n],{n,1,1000}], Joined->True, PlotStyle->Black, PlotRange->{0,300}];
PlotNetLevyDisplacement2=ListPlot[Table[NetLevyDisplacement2[n],{n,1,1000}], Joined->True, PlotStyle->Red, PlotRange->{0,300}];
PlotNetLevyDisplacement3=ListPlot[Table[NetLevyDisplacement3[n],{n,1,1000}], Joined->True, PlotStyle->Blue, PlotRange->{0,300}];
PlotNetLevyDisplacement4=ListPlot[Table[NetLevyDisplacement4[n],{n,1,1000}], Joined->True, PlotStyle->Green, PlotRange->{0,300}];



LevyDisplacements=Show[PlotNetLevyDisplacement1 ,PlotNetLevyDisplacement2,PlotNetLevyDisplacement3,PlotNetLevyDisplacement4]

Manipulate[Plot[(N^α),{N,0,1000}, PlotRange->{0,300}],{α,.5,1}]

LevyPowerLaw[α_]:=Plot[(N^α),{N,0,1000}, PlotRange->{0,300}]

Manipulate[Show[LevyDisplacements,LevyPowerLaw[α]],{α,.5,1}]

EvolvingMeanOfNetLevyDisplacements=Table[Mean[{NetLevyDisplacement1[n],NetLevyDisplacement2[n],NetLevyDisplacement3[n],NetLevyDisplacement4[n]}],{n,1,1000}];

EvolvingMeanGraph=ListPlot[EvolvingMeanOfNetLevyDisplacements,PlotRange->{0,300},Joined->True]

Manipulate[Show[EvolvingMeanGraph,LevyPowerLaw[α]],{α,.5,1}]

The theoretical distribtion

(Subscript[ρ, Levi])[x,y,N]

satisfies a "fractional diffusion equation"

(1/2)((∂_(x,x))+(∂_(y,y)))ρ=(([(∂_N)])^f)ρ

where (([(∂_N)])^f) is a "fractional derivative."

ADDENDUM: See the end of "Spectra of Random Matrices" (Notebook: 6 February 2010), where I record first encounter with the command

?RandomChoice

RandomChoice[{-1,+1},20]

Table[Graphics[Line[Accumulate[RandomChoice[{-1,0,1},{1000,2}]]]],{k,1,5}]//TableForm

Table[Graphics[Line[Accumulate[RandomChoice[{-1,0,1},{1000,2}]]]],{k,1,5}]//TableForm

Table[Graphics[Line[Accumulate[RandomChoice[{-1,1},{1000,2}]]]],{k,1,5}]//TableForm

Table[Graphics[Line[Accumulate[RandomChoice[{-1,1},{1000,2}]]]],{k,1,2}]//TableForm

?Accumulate

Graphics[{{Red,Line[Accumulate[RandomChoice[{-1,1},{1000,2}]]]},{Blue,Line[Accumulate[RandomChoice[{-1,1},{1000,2}]]]},{Point[{0,0}]}}]

RandomChoice[{-1,0,1},{10,2}]